home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume6 / xlisp1.6 / part5 < prev    next >
Encoding:
Internet Message Format  |  1986-11-30  |  51.4 KB
  1. Subject:  v06i111:  Xlisp version 1.6 (xlisp1.6), Part05/06
  2. Newsgroups: mod.sources
  3. Approved: rs@mirror.UUCP
  4.  
  5. Submitted by: seismo!utah-cs!b-davis (Brad Davis)
  6. Mod.sources: Volume 6, Issue 111
  7. Archive-name: xlisp1.6/Part05
  8.  
  9.  
  10. #! /bin/sh
  11. # This is a shell archive, meaning:
  12. # 1. Remove everything above the #! /bin/sh line.
  13. # 2. Save the resulting text in a file.
  14. # 3. Execute the file with /bin/sh (not csh) to create the files:
  15. #    art.lsp
  16. #    example.lsp
  17. #    fact.lsp
  18. #    fib.lsp
  19. #    hanoi.lsp
  20. #    hdwr.lsp
  21. #    ifthen.lsp
  22. #    init.lsp
  23. #    object.lsp
  24. #    pcturtle.lsp
  25. #    pp.lsp
  26. #    prolog.lsp
  27. #    pt.lsp
  28. #    queens.lsp
  29. #    queens2.lsp
  30. #    simplepp.lsp
  31. #    trace.lsp
  32. # This archive created: Mon Jul 14 10:16:59 1986
  33. export PATH; PATH=/bin:$PATH
  34. if test -f 'art.lsp'
  35. then
  36.     echo shar: will not over-write existing file "'art.lsp'"
  37. else
  38. cat << \SHAR_EOF > 'art.lsp'
  39. ; This is an example using the object-oriented programming support in
  40. ; XLISP.  The example involves defining a class of objects representing
  41. ; dictionaries.  Each instance of this class will be a dictionary in
  42. ; which names and values can be stored.  There will also be a facility
  43. ; for finding the values associated with names after they have been
  44. ; stored.
  45.  
  46. ; Create the 'Dictionary' class and establish its instance variable list.
  47. ; The variable 'entries' will point to an association list representing the
  48. ; entries in the dictionary instance.
  49.  
  50. (setq Dictionary (Class :new '(entries)))
  51.  
  52. ; Setup the method for the ':isnew' initialization message.
  53. ; This message will be send whenever a new instance of the 'Dictionary'
  54. ; class is created.  Its purpose is to allow the new instance to be
  55. ; initialized before any other messages are sent to it.  It sets the value
  56. ; of 'entries' to nil to indicate that the dictionary is empty.
  57.  
  58. (Dictionary :answer :isnew '()
  59.         '((setq entries nil)
  60.           self))
  61.  
  62. ; Define the message ':add' to make a new entry in the dictionary.  This
  63. ; message takes two arguments.  The argument 'name' specifies the name
  64. ; of the new entry; the argument 'value' specifies the value to be
  65. ; associated with that name.
  66.  
  67. (Dictionary :answer :add '(name value)
  68.         '((setq entries
  69.                 (cons (cons name value) entries))
  70.           value))
  71.  
  72. ; Create an instance of the 'Dictionary' class.  This instance is an empty
  73. ; dictionary to which words may be added.
  74.  
  75. (setq d (Dictionary :new))
  76.  
  77. ; Add some entries to the new dictionary.
  78.  
  79. (d :add 'mozart 'composer)
  80. (d :add 'winston 'computer-scientist)
  81.  
  82. ; Define a message to find entries in a dictionary.  This message takes
  83. ; one argument 'name' which specifies the name of the entry for which to
  84. ; search.  It returns the value associated with the entry if one is
  85. ; present in the dictionary.  Otherwise, it returns nil.
  86.  
  87. (Dictionary :answer :find '(name &aux entry)
  88.         '((cond ((setq entry (assoc name entries))
  89.           (cdr entry))
  90.          (t
  91.           nil))))
  92.  
  93. ; Try to find some entries in the dictionary we created.
  94.  
  95. (d :find 'mozart)
  96. (d :find 'winston)
  97. (d :find 'bozo)
  98.  
  99. ; The names 'mozart' and 'winston' are found in the dictionary so their
  100. ; values 'composer' and 'computer-scientist' are returned.  The name 'bozo'
  101. ; is not found so nil is returned in this case.
  102. SHAR_EOF
  103. fi # end of overwriting check
  104. if test -f 'example.lsp'
  105. then
  106.     echo shar: will not over-write existing file "'example.lsp'"
  107. else
  108. cat << \SHAR_EOF > 'example.lsp'
  109. ; Make the class ship and its instance variables be known
  110.  
  111. (setq ship (Class :new '(x y xv yv m name captain registry)))
  112.  
  113.  
  114. (ship :answer :getx        '() '( x ))    ; just evaluate x
  115. (ship :answer :getxv        '() '( xv ))    ; note that the method is a
  116. (ship :answer :gety        '() '( y ))    ; list of forms, the value
  117. (ship :answer :getyv        '() '( yv ))    ; of the last one being the
  118. (ship :answer :getm        '() '( m ))    ; value of the method
  119. (ship :answer :getname        '() '( name ))
  120. (ship :answer :getcaptain    '() '( captain ))
  121. (ship :answer :getregistry    '() '( registry ))
  122.  
  123. ;               formal
  124. ;               param
  125. ;               of
  126. ;               method
  127. (ship :answer :setx         '(to) '( (setq x to) ) )
  128. (ship :answer :setxv        '(to) '( (setq xv to) ) )
  129. (ship :answer :sety         '(to) '( (setq y to) ) )
  130. (ship :answer :setyv       '(to) '( (setq yv to) ) )
  131. (ship :answer :setm       '(to) '( (setq m to) ) )
  132. (ship :answer :setname     '(to) '( (setq name to) ) )
  133. (ship :answer :setcaptain  '(to) '( (setq captain to) ) )
  134. (ship :answer :setregistry '(to) '( (setq registry to) ) )
  135.  
  136. (ship :answer :sail '(time) 
  137.     ; the METHOD for sailing
  138.     '( (princ (list "sailing for " time " hours\n"))
  139.        ; note that this form is expressed in terms of objects:  "self"
  140.        ; is bound to the object being talked to during the execution
  141.        ; of its message.  It can ask itself to do things.
  142.        (self :setx (+  (self :getx)
  143.                (* (self :getxv) time)))
  144.        ; This form performs a parallel action to the above, but more
  145.        ; efficiently, and in this instance, more clearly
  146.        (setq y (+ y (* yv time)))
  147.        ; Cute message for return value.  Tee Hee.
  148.        "Sailing, sailing, over the bountiful chow mein..."))
  149.  
  150. ; <OBJECT: #12345667> is not terribly instructive.  How about a more
  151. ; informative print routine?
  152.  
  153. (ship :answer :print '() '((princ (list
  154.                 "SHIP NAME: " (self :getname) "\n"
  155.                 "REGISTRY: " (self :getregistry) "\n"
  156.                 "CAPTAIN IS: " (self :getcaptain) "\n"
  157.                 "MASS IS: " (self :getm) " TONNES\n"
  158.                 "CURRENT POSITION IS: " 
  159.                     (self :getx)    " X BY "
  160.                     (self :gety)    " Y\n"
  161.                 "SPEED IS: "
  162.                     (self :getxv)    " XV BY "
  163.                     (self :getyv)    " YV\n") ) ))
  164.  
  165. ; a function to make life easier
  166.  
  167. (defun newship (mass name registry captain &aux new)
  168.     (setq new (ship :new))
  169.     (new :setx 0)
  170.     (new :sety 0)
  171.     (new :setxv 0)
  172.     (new :setyv 0)
  173.     (new :setm mass)
  174.     (new :setname name)
  175.     (new :setcaptain captain)
  176.     (new :setregistry registry)
  177.     (new :print)
  178.     new)
  179.  
  180. ; and an example object.
  181.  
  182. (setq Bounty (newship 50 'Bounty 'England 'Bligh))
  183. SHAR_EOF
  184. fi # end of overwriting check
  185. if test -f 'fact.lsp'
  186. then
  187.     echo shar: will not over-write existing file "'fact.lsp'"
  188. else
  189. cat << \SHAR_EOF > 'fact.lsp'
  190. (defun factorial (n)
  191.        (cond ((= n 1) 1)
  192.          (t (* n (factorial (- n 1))))))
  193. SHAR_EOF
  194. fi # end of overwriting check
  195. if test -f 'fib.lsp'
  196. then
  197.     echo shar: will not over-write existing file "'fib.lsp'"
  198. else
  199. cat << \SHAR_EOF > 'fib.lsp'
  200. (defun fib (x)
  201.        (if (< x 2)
  202.            x
  203.            (+ (fib (1- x)) (fib (- x 2)))))
  204.  
  205.  
  206. SHAR_EOF
  207. fi # end of overwriting check
  208. if test -f 'hanoi.lsp'
  209. then
  210.     echo shar: will not over-write existing file "'hanoi.lsp'"
  211. else
  212. cat << \SHAR_EOF > 'hanoi.lsp'
  213. ; Good ol towers of hanoi
  214. ;
  215. ; Usage:
  216. ;      (hanoi <n>)
  217. ;          <n> - an integer the number of discs
  218.  
  219. (defun hanoi(n)
  220.   ( transfer 'A 'B 'C n ))
  221.  
  222. (defun print-move ( from to )
  223.   (princ "Move Disk From ")
  224.   (princ from)
  225.   (princ " To ")
  226.   (princ to)
  227.   (princ "\n"))
  228.  
  229.  
  230. (defun transfer ( from to via n )
  231.   (cond ((equal n 1) (print-move from to ))
  232.     (t (transfer from via to (- n 1))
  233.        (print-move from to)
  234.        (transfer via to from (- n 1)))))
  235.  
  236.  
  237. SHAR_EOF
  238. fi # end of overwriting check
  239. if test -f 'hdwr.lsp'
  240. then
  241.     echo shar: will not over-write existing file "'hdwr.lsp'"
  242. else
  243. cat << \SHAR_EOF > 'hdwr.lsp'
  244. ; -*-Lisp-*-
  245. ;
  246. ; Jwahar R. Bammi
  247. ; A simple description of hardware objects using xlisp
  248. ; Mix and match instances of the objects to create your
  249. ; organization.
  250. ; Needs:
  251. ; - busses and connection and the Design
  252. ;   Class that will have the connections as instance vars.
  253. ; - Print method for each object, that will display
  254. ;   the instance variables in an human readable form.
  255. ; Some day I will complete it.
  256. ;
  257. ;
  258. ;
  259. ; utility functions
  260.  
  261.  
  262. ; function to calculate 2^n
  263.  
  264. (defun pow2 (n)
  265.     (pow2x n 1))
  266.  
  267. (defun pow2x (n sum)
  268.        (cond((equal n 0) sum)
  269.         (t (pow2x (- n 1) (* sum 2)))))
  270.  
  271.  
  272. ; hardware objects
  273.  
  274. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  275. ;The class areg
  276.  
  277. (setq areg (Class :new '(value nbits max_val min_val)))
  278.  
  279. ; methods
  280.  
  281. ; initialization method
  282. ; when a new instance is called for the user supplies
  283. ; the parameter nbits, from which the max_val & min_val are derived
  284.  
  285. (areg :answer :isnew '(n)
  286.       '((self :init n)
  287.             self))
  288.  
  289. (areg :answer :init '(n)
  290.       '((setq value ())
  291.         (setq nbits n)
  292.         (setq max_val (- (pow2 (- n 1)) 1))
  293.         (setq min_val (- (- 0 max_val) 1))))
  294.  
  295. ; load areg
  296.  
  297. (areg :answer :load '(val)
  298.       '((cond ((> val max_val) (princ (list "The max value a "nbits" bit register can hold is "max_val"\n")))
  299.           ((< val min_val) (princ (list "The min value a "nbits" bit register can hold is "min_val"\n")))
  300.           (t (setq value val)))))
  301.  
  302. ; see areg
  303.  
  304. (areg :answer :see '()
  305.       '((cond ((null value) (princ "Register does not contain a value\n"))
  306.           (t value))))
  307. ;
  308. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  309.  
  310. ; The class creg ( a register that can be cleared and incremented)
  311. ; subclass of a reg
  312.  
  313. (setq creg (Class :new '() '() areg))
  314.  
  315. ; it inherites all the instance vars & methods of a reg
  316. ; in addition to them it has the following methods
  317.  
  318. (creg :answer :isnew '(n)
  319.       '((self :init n)
  320.     self))
  321.  
  322. (creg :answer :init '(n)
  323.       '((setq value ())
  324.     (setq nbits n)
  325.     (setq max_val (- (pow2 n) 1))
  326.     (setq min_val 0)))
  327.  
  328. (creg :answer :clr '()
  329.       '((setq value 0)))
  330.  
  331. (creg :answer :inc '()
  332.       '((cond ((null value) (princ "Register does not contain a value\n"))
  333.           (t (setq value (rem (+ value 1) (+ max_val 1)))))))
  334.  
  335. ;
  336. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  337. ;
  338. ; Register bank
  339. ; contains n areg's n_bits each
  340.  
  341. (setq reg_bank (Class :new '(regs n_regs curr_reg)))
  342.  
  343. ;methods
  344.  
  345. (reg_bank :answer :isnew '(n n_bits)
  346.       '((self :init n n_bits)
  347.         self))
  348.  
  349. (reg_bank :answer :init '(n n_bits)
  350.       '((setq regs ())
  351.         (setq n_regs (- n 1))
  352.         (self :initx n n_bits)))
  353.  
  354. (reg_bank :answer :initx '(n n_bits)
  355.       '((cond ((equal n 0) t)
  356.               (t (list (setq regs (cons (areg :new n_bits) regs))
  357.           (self :initx (setq n (- n 1)) n_bits))))))
  358.  
  359. (reg_bank :answer :load '(reg val)
  360.       '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
  361.          (t (setq curr_reg (nth (+ reg 1) regs))
  362.             (curr_reg :load val)))))
  363.  
  364. (reg_bank :answer :see '(reg)
  365.       '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
  366.          (t (setq curr_reg (nth (+ reg 1) regs))
  367.             (curr_reg :see)))))
  368. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  369. ; The Class alu
  370.  
  371. ;alu - an n bit alu
  372.  
  373. (setq alu (Class :new '(n_bits maxs_val mins_val maxu_val minu_val nf zf vf cf)))
  374.  
  375. ; methods
  376.  
  377. (alu :answer :isnew '(n)
  378.      '((self :init n)
  379.        self))
  380.  
  381. (alu :answer :init '(n)
  382.      '((setq n_bits n)
  383.        (setq maxu_val (- (pow2 n) 1))
  384.        (setq maxs_val (- (pow2 (- n 1)) 1))
  385.        (setq mins_val (- (- 0 maxs_val) 1))
  386.        (setq minu_val 0)
  387.        (setq nf 0)
  388.        (setq zf 0)
  389.        (setq vf 0)
  390.        (setq cf 0)))
  391.  
  392. (alu :answer :check_arith '(a b)
  393.      '((cond ((and (self :arith_range a) (self :arith_range b)) t)
  394.          (t ()))))
  395.  
  396. (alu :answer :check_logic '(a b)
  397.      '((cond ((and (self :logic_range a) (self :logic_range b)) t)
  398.          (t ()))))
  399.  
  400. (alu :answer :arith_range '(a)
  401.      '((cond ((< a mins_val) (princ (list "Operand out of Range "a"\n")))
  402.          ((> a maxs_val) (princ (list "Operand out of range "a"\n")))
  403.              (t t))))
  404.  
  405. (alu :answer :logic_range '(a)
  406.      '((cond ((< (abs a) minu_val) (princ (list "Operand out of Range "a"\n")))
  407.              (t t))))
  408.  
  409. (alu :answer :set_flags '(a b r)
  410.      '((if (equal 0 r) ((setq zf 1)))
  411.        (if (< r 0) ((setq nf 1)))
  412.        (if (or (and (and (< a 0) (< 0 b)) (>= r 0))
  413.           (and (and (>= a 0) (>= b 0)) (< r 0))) ((setq vf 1)))
  414.        (if (or (or (and (< a 0) (< b 0)) (and (< a 0) (>= r 0)))
  415.           (and (>= r 0) (< b 0))) ((setq cf 1)))))
  416.        
  417. (alu :answer :+ '(a b &aux result)
  418.      '((cond ((null (self :check_arith a b)) ())
  419.         (t (self :clear_flags)
  420.            (setq result (+ a b))
  421.            (if (> result maxs_val) ((setq result (+ (- (rem result maxs_val) 1) mins_val))))
  422.            (if (< result mins_val) ((setq result (+ (rem result mins_val) (+ maxs_val 1)))))
  423.            (self :set_flags a b result)
  424.            result))))
  425.  
  426. (alu :answer :& '(a b &aux result)
  427.      '((cond ((null (self :check_logic a b)) ())
  428.         (t (self :clear_flags)
  429.            (setq result (bit-and a b))
  430.            (self :set_flags a b result)
  431.            result))))
  432.  
  433. (alu :answer :| '(a b &aux result)
  434.      '((cond ((null (self :check_logic a b)) ())
  435.         (t (self :clear_flags)
  436.            (setq result (bit-ior a b))
  437.            (self :set_flags a b result)
  438.            result))))
  439.  
  440. (alu :answer :~ '(a  &aux result)
  441.      '((cond ((null (self :check_logic a 0)) ())
  442.         (t (self :clear_flags)
  443.            (setq result (bit-not a))
  444.            (self :set_flags a 0 result)
  445.            result))))           
  446.  
  447. (alu :answer :- '(a b)
  448.      '((self '+ a (- 0 b))))
  449.  
  450. (alu :answer :passa '(a)
  451.      '(a))
  452.  
  453. (alu :answer :zero '()
  454.      '(0))
  455.  
  456. (alu :answer :com '(a)
  457.      '((self :- 0 a)))
  458.  
  459. (alu :answer :status '()
  460.      '((princ (list "NF "nf"\n"))
  461.        (princ (list "ZF "zf"\n"))
  462.        (princ (list "CF "cf"\n"))
  463.        (princ (list "VF "vf"\n"))))
  464.  
  465. (alu :answer :clear_flags '()
  466.      '((setq nf 0)
  467.        (setq zf 0)
  468.        (setq cf 0)
  469.        (setq vf 0)))
  470.  
  471. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  472. ;
  473. ; The class Memory
  474. ;
  475.  
  476. (setq memory (Class :new '(nabits ndbits maxu_val maxs_val mins_val max_addr undef memry)))
  477.  
  478. ; methods
  479.  
  480. (memory :answer :isnew '(addr_bits data_bits)
  481.      '((self :init addr_bits data_bits)
  482.        self))
  483.  
  484. (memory :answer :init '(addr_bits data_bits)
  485.      '((setq nabits addr_bits)
  486.        (setq ndbits data_bits)
  487.        (setq maxu_val (- (pow2 data_bits) 1))
  488.        (setq max_addr (- (pow2 addr_bits) 1))
  489.        (setq maxs_val (- (pow2 (- data_bits 1)) 1))
  490.        (setq mins_val (- 0 (pow2 (- data_bits 1))))
  491.        (setq undef (+ maxu_val 1))
  492.        (setq memry (array :new max_addr undef))))
  493.  
  494.  
  495. (memory :answer :load '(loc val)
  496.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  497.          ((< val 0) (princ (list "Cant store "val" in "ndbits" bits\n")))
  498.          ((> val maxu_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  499.          (t (memry :load loc val)))))
  500.  
  501. (memory :answer :write '(loc val)
  502.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  503.          ((> val maxs_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  504.          ((< val mins_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  505.          (t (memry :load loc val)))))
  506.  
  507.  
  508. (memory :answer :read '(loc &aux val)
  509.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  510.          (t (setq val (memry :see loc))
  511.         (cond ((equal undef val) (princ (list "Address "loc" read before write\n")))
  512.               (t val))))))
  513.  
  514.  
  515. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  516. ;
  517. ; The class array
  518.  
  519. (setq array (Class :new '(arry)))
  520.  
  521. ; methods
  522.  
  523. (array :answer :isnew '(n val)
  524.        '((self :init n val)
  525.      self))
  526.  
  527. (array :answer :init '(n val)
  528.     '((cond ((< n 0) t)
  529.           (t (setq arry (cons val arry))
  530.          (self :init (- n 1) val)))))
  531.  
  532. (array :answer :see '(n)
  533.            '((nth (+ n 1) arry)))
  534.  
  535.  
  536. (array :answer :load '(n val &aux left right temp)
  537.        '((setq left (self :left_part n arry temp))
  538.      (setq right (self :right_part n arry))
  539.      (setq arry (append left (list val)))
  540.      (setq arry (append arry right))
  541.      val))
  542.  
  543. (array :answer :left_part '(n ary left)
  544.        '((cond ((equal n 0) (reverse left))
  545.            (t (setq left (cons (car ary) left))
  546.           (self :left_part (- n 1) (cdr ary) left)))))
  547.  
  548. (array :answer :right_part '(n ary &aux right)
  549.        '((cond ((equal n 0) (cdr ary))
  550.            (t (self :right_part (- n 1) (cdr ary))))))
  551.  
  552. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  553. SHAR_EOF
  554. fi # end of overwriting check
  555. if test -f 'ifthen.lsp'
  556. then
  557.     echo shar: will not over-write existing file "'ifthen.lsp'"
  558. else
  559. cat << \SHAR_EOF > 'ifthen.lsp'
  560. ; -*-Lisp-*-
  561. ;
  562. ; If then rules - mini expert from Ch. 18 of Winston and Horn
  563. ; Written using recursion without progs
  564. ; Added function 'how' to explain deductions
  565. ;
  566. ; Use:
  567. ;    After loading type (deduce). It will make all the deductions
  568. ;    given the list fact. If you want to know how it deduced something
  569. ;    type (how '(a deduction)) for example (how '(animal is tiger))
  570. ;    and so on.
  571.  
  572.  
  573.  
  574. ; rules data base
  575.  
  576. (setq rules
  577.       '((rule identify1
  578.           (if (animal has hair))
  579.           (then (animal is mammal)))
  580.     (rule identify2
  581.           (if (animal gives milk))
  582.           (then (animal is mammal)))
  583.     (rule identify3
  584.           (if (animal has feathers))
  585.           (then (animal is bird)))
  586.     (rule identify4
  587.           (if (animal flies)
  588.           (animal lays eggs))
  589.           (then (animal is bird)))
  590.     (rule identify5
  591.           (if (animal eats meat))
  592.           (then (animal is carnivore)))
  593.     (rule identify6
  594.           (if (animal has pointed teeth)
  595.           (animal has claws)
  596.           (animal has forward eyes))
  597.           (then (animal is carnivore)))
  598.     (rule identify7
  599.           (if (animal is mammal)
  600.           (animal has hoofs))
  601.           (then (animal is ungulate)))
  602.     (rule identify8
  603.           (if (animal is mammal)
  604.           (animal chews cud))
  605.           (then (animal is ungulate)
  606.             (even toed)))
  607.     (rule identify9
  608.           (if (animal is mammal)
  609.           (animal is carnivore)
  610.           (animal has tawny color)
  611.           (animal has dark spots))
  612.           (then (animal is cheetah)))
  613.     (rule identify10
  614.           (if (animal is mammal)
  615.           (animal is carnivore)
  616.           (animal has tawny color)
  617.           (animal has black stripes))
  618.           (then (animal is tiger)))
  619.     (rule identify11
  620.           (if (animal is ungulate)
  621.           (animal has long neck)
  622.           (animal has long legs)
  623.           (animal has dark spots))
  624.           (then (animal is giraffe)))
  625.     (rule identify12
  626.           (if (animal is ungulate)
  627.           (animal has black stripes))
  628.           (then (animal is zebra)))
  629.     (rule identify13
  630.           (if (animal is bird)
  631.           (animal does not fly)
  632.           (animal has long neck)
  633.           (animal has long legs)
  634.           (animal is black and white))
  635.           (then (animal is ostrich)))
  636.     (rule identify14
  637.           (if (animal is bird)
  638.           (animal does not fly)
  639.           (animal swims)
  640.           (animal is black and white))
  641.           (then (animal is penguin)))
  642.     (rule identify15
  643.           (if (animal is bird)
  644.           (animal flys well))
  645.           (then (animal is albatross)))))
  646. ; utility functions
  647. (defun squash(s)
  648.        (cond ((null s) ())
  649.          ((atom s) (list s))
  650.          (t (append (squash (car s))
  651.             (squash (cdr s))))))
  652.  
  653. (defun p(s)
  654.        (princ (squash s)))
  655.  
  656. ; functions
  657.  
  658. ; function to see if an item is a member of a list
  659.  
  660. (defun member(item list)
  661.        (cond((null list) ())    ; return nil on end of list
  662.         ((equal item (car list)) list) ; found
  663.         (t (member item (cdr list))))) ; otherwise try rest of list
  664.  
  665. ; put a new fact into the facts data base if it is not already there
  666.  
  667. (defun remember(newfact)
  668.        (cond((member newfact facts) ())    ; if present do nothing
  669.         (t ( setq facts (cons newfact facts)) newfact)))
  670.  
  671. ; is a fact there in the facts data base
  672.  
  673. (defun recall(afact)
  674.        (cond ((member afact facts) afact)    ; it is here
  675.          (t ())))                ; no it is'nt
  676.  
  677. ; given a rule check if all the if parts are confirmed by the facts data base
  678.  
  679. (defun testif(iflist)
  680.        (cond((null iflist) t)    ; all satisfied
  681.         ((recall (car iflist)) (testif (cdr iflist))) ; keep searching
  682.                                       ; if one is ok
  683.         (t ())))                    ; not in facts DB
  684.  
  685. ; add the then parts of the rules which can be added to the facts DB
  686. ; return the ones that are added
  687.  
  688. (defun usethen(thenlist addlist)
  689.        (cond ((null thenlist) addlist) ; all exhausted
  690.          ((remember (car thenlist))
  691.          (usethen (cdr thenlist) (cons (car thenlist) addlist)))
  692.          (t (usethen (cdr thenlist) addlist))))
  693.  
  694. ; try a rule
  695. ; return t only if all the if parts are satisfied by the facts data base
  696. ; and at lest one then ( conclusion ) is added to the facts data base
  697.  
  698. (defun tryrule(rule &aux ifrules thenlist addlist)
  699.        (setq ifrules (cdr(car(cdr(cdr rule)))))
  700.        (setq thenlist (cdr(car(cdr(cdr(cdr rule))))))
  701.        (setq addlist '())
  702.        (cond (( testif ifrules)
  703.           (cond ((setq addlist (usethen thenlist addlist))
  704.              (p (list "Rule " (car(cdr rule)) "\n\tDeduced " addlist "\n\n"))
  705.              (setq ruleused (cons rule ruleused))
  706.              t)
  707.             (t ())))
  708.          (t ())))
  709.  
  710. ; step through one iteration if the forward search
  711. ; looking for rules that can be deduced from the present fact data base
  712.  
  713. (defun stepforward( rulelist)
  714.        (cond((null rulelist) ())    ; all done
  715.         ((tryrule (car rulelist)) t)
  716.         ( t (stepforward(cdr rulelist)))))
  717.  
  718. ; stepforward until you cannot go any further
  719.  
  720. (defun deduce()
  721.       (cond((stepforward rules) (deduce))
  722.        (t t)))
  723.  
  724. ; function to answer if a fact was used to come to a certain conclusion
  725. ; uses the ruleused list cons'ed by tryrule to answer
  726.  
  727. (defun usedp(rule)
  728.        (cond ((member rule ruleused) t)    ; it has been used
  729.          (t () )))            ; no it hasnt
  730.  
  731. ; function to answer how a fact was deduced
  732.  
  733. (defun how(fact)
  734.        (how2 fact ruleused nil))
  735.  
  736. (defun how2(fact rulist found)
  737.        (cond ((null rulist)    ; if the rule list exhausted
  738.           (cond (found t)   ; already answered the question return t
  739.             ((recall fact) (p (list fact " was a given fact\n")) t) ;known fact
  740.             (t (p (list fact " -- not a fact!\n")) ())))
  741.           
  742.           ((member fact (thenpart (car rulist)))     ; if rulist not empty
  743.            (setq found t)    ; and fact belongs to the then part of a rule
  744.            (p (list fact " was deduced because the following were true\n"))
  745.            (printifs (car rulist))
  746.            (how2 fact (cdr rulist) found))
  747.           (t (how2 fact (cdr rulist) found))))
  748.  
  749. ; function to return the then part of a rule
  750.  
  751. (defun thenpart(rule)
  752.        (cdr(car(cdr(cdr(cdr rule))))))
  753.  
  754. ; function to print the if part of a given rule
  755.  
  756. (defun printifs(rule)
  757.        (pifs (cdr(car(cdr(cdr rule))))))
  758.  
  759. (defun pifs(l)
  760.     (cond ((null l) ())
  761.           (t (p (list "\t" (car l) "\n"))
  762.          (pifs (cdr l)))))
  763.  
  764.  
  765. ; initial facts data base
  766. ; Uncomment one or make up your own
  767. ; Then run 'deduce' to find deductions
  768. ; Run 'how' to find out how it came to a certain deduction
  769.  
  770. ;(setq facts
  771. ;      '((animal has dark spots)
  772. ;    (animal has tawny color)
  773. ;    (animal eats meat)
  774. ;    (animal has hair)))
  775.  
  776. (setq facts
  777.       '((animal has hair)
  778.     (animal has pointed teeth)
  779.     (animal has black stripes)
  780.     (animal has claws)
  781.     (animal has forward eyes)
  782.     (animal has tawny color)))
  783.  
  784.  
  785. (setq rl1
  786.           '(rule identify14
  787.           (if (animal is bird)
  788.           (animal does not fly)
  789.           (animal swims)
  790.           (animal is black and white))
  791.           (then (animal is penguin))))
  792.  
  793. (setq rl2
  794.         '(rule identify10
  795.           (if (animal is mammal)
  796.           (animal is carnivore)
  797.           (animal has tawny color)
  798.           (animal has black stripes))
  799.           (then (animal is tiger))))
  800.  
  801. ; Initialization
  802. (expand 10)
  803. (setq ruleused nil)
  804. SHAR_EOF
  805. fi # end of overwriting check
  806. if test -f 'init.lsp'
  807. then
  808.     echo shar: will not over-write existing file "'init.lsp'"
  809. else
  810. cat << \SHAR_EOF > 'init.lsp'
  811. ; initialization file for XLISP 1.6
  812.  
  813. ; get some more memory
  814. (expand 1)
  815.  
  816. ; some fake definitions for Common Lisp pseudo compatiblity
  817. (setq first  car)
  818. (setq second cadr)
  819. (setq rest   cdr)
  820.  
  821. ; (when test code...) - execute code when test is true
  822. (defmacro when (test &rest code)
  823.           `(cond (,test ,@code)))
  824.  
  825. ; (unless test code...) - execute code unless test is true
  826. (defmacro unless (test &rest code)
  827.           `(cond ((not ,test) ,@code)))
  828.  
  829. ; (makunbound sym) - make a symbol be unbound
  830. (defun makunbound (sym) (setq sym '*unbound*) sym)
  831.  
  832. ; (objectp expr) - object predicate
  833. (defun objectp (x) (eq (type-of x) :OBJECT))
  834.  
  835. ; (filep expr) - file predicate
  836. (defun filep (x) (eq (type-of x) :FILE))
  837.  
  838. ; (unintern sym) - remove a symbol from the oblist
  839. (defun unintern (sym) (cond ((member sym *oblist*)
  840.                              (setq *oblist* (delete sym *oblist*))
  841.                              t)
  842.                             (t nil)))
  843.  
  844. ; (mapcan fun list [ list ]...)
  845. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  846.  
  847. ; (mapcon fun list [ list ]...)
  848. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  849.  
  850. ; (set-macro-character ch fun [ tflag ])
  851. (defun set-macro-character (ch fun &optional tflag)
  852.     (setf (aref *readtable* ch) (cons (if tflag :tmacro :nmacro) fun))
  853.     t)
  854.  
  855. ; (get-macro-character ch)
  856. (defun get-macro-character (ch)
  857.   (if (consp (aref *readtable* ch))
  858.     (cdr (aref *readtable* ch))
  859.     nil))
  860.  
  861. ; (save fun) - save a function definition to a file
  862. (defmacro save (fun)
  863.          `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  864.                  (fval (car ,fun))
  865.                  (fp (openo fname)))
  866.                 (cond (fp (print (cons (if (eq (car fval) 'lambda)
  867.                                            'defun
  868.                                            'defmacro)
  869.                                        (cons ',fun (cdr fval))) fp)
  870.                           (close fp)
  871.                           fname)
  872.                       (t nil))))
  873.  
  874. ; (debug) - enable debug breaks
  875. (defun debug ()
  876.        (setq *breakenable* t))
  877.  
  878. ; (nodebug) - disable debug breaks
  879. (defun nodebug ()
  880.        (setq *breakenable* nil))
  881.  
  882. ; initialize to enable breaks but no trace back
  883. (setq *breakenable* t)
  884. (setq *tracenable* nil)
  885.  
  886. SHAR_EOF
  887. fi # end of overwriting check
  888. if test -f 'object.lsp'
  889. then
  890.     echo shar: will not over-write existing file "'object.lsp'"
  891. else
  892. cat << \SHAR_EOF > 'object.lsp'
  893. ; This is an example using the object-oriented programming support in
  894. ; XLISP.  The example involves defining a class of objects representing
  895. ; dictionaries.  Each instance of this class will be a dictionary in
  896. ; which names and values can be stored.  There will also be a facility
  897. ; for finding the values associated with names after they have been
  898. ; stored.
  899.  
  900. ; Create the 'Dictionary' class.
  901.  
  902. (setq Dictionary (Class 'new))
  903.  
  904. ; Establish the instance variables for the new class.
  905. ; The variable 'entries' will point to an association list representing the
  906. ; entries in the dictionary instance.
  907.  
  908. (Dictionary 'ivars '(entries))
  909.  
  910. ; Setup the method for the 'isnew' initialization message.
  911. ; This message will be send whenever a new instance of the 'Dictionary'
  912. ; class is created.  Its purpose is to allow the new instance to be
  913. ; initialized before any other messages are sent to it.  It sets the value
  914. ; of 'entries' to nil to indicate that the dictionary is empty.
  915.  
  916. (Dictionary 'answer 'isnew '()
  917.         '((setq entries nil)
  918.           self))
  919.  
  920. ; Define the message 'add' to make a new entry in the dictionary.  This
  921. ; message takes two arguments.  The argument 'name' specifies the name
  922. ; of the new entry; the argument 'value' specifies the value to be
  923. ; associated with that name.
  924.  
  925. (Dictionary 'answer 'add '(name value)
  926.         '((setq entries
  927.                 (cons (cons name value) entries))
  928.           value))
  929.  
  930. ; Create an instance of the 'Dictionary' class.  This instance is an empty
  931. ; dictionary to which words may be added.
  932.  
  933. (setq d (Dictionary 'new))
  934.  
  935. ; Add some entries to the new dictionary.
  936.  
  937. (d 'add 'mozart 'composer)
  938. (d 'add 'winston 'computer-scientist)
  939.  
  940. ; Define a message to find entries in a dictionary.  This message takes
  941. ; one argument 'name' which specifies the name of the entry for which to
  942. ; search.  It returns the value associated with the entry if one is
  943. ; present in the dictionary.  Otherwise, it returns nil.
  944.  
  945. (Dictionary 'answer 'find '(name &aux entry)
  946.         '((cond ((setq entry (assoc name entries))
  947.           (cdr entry))
  948.          (t
  949.           nil))))
  950.  
  951. ; Try to find some entries in the dictionary we created.
  952.  
  953. (d 'find 'mozart)
  954. (d 'find 'winston)
  955. (d 'find 'bozo)
  956.  
  957. ; The names 'mozart' and 'winston' are found in the dictionary so their
  958. ; values 'composer' and 'computer-scientist' are returned.  The name 'bozo'
  959. ; is not found so nil is returned in this case.
  960. SHAR_EOF
  961. fi # end of overwriting check
  962. if test -f 'pcturtle.lsp'
  963. then
  964.     echo shar: will not over-write existing file "'pcturtle.lsp'"
  965. else
  966. cat << \SHAR_EOF > 'pcturtle.lsp'
  967. ; This is a sample XLISP program
  968. ; It implements a simple form of programmable turtle for IBM-PC compatible
  969. ; machines.
  970.  
  971. ; To run it:
  972.  
  973. ;    A>xlisp pt
  974.  
  975. ; This should cause the screen to be cleared and two turtles to appear.
  976. ; They should each execute their simple programs and then the prompt
  977. ; should return.  Look at the code to see how all of this works.
  978.  
  979. ; Get some more memory
  980. (expand 1)
  981.  
  982. ; Move the cursor to the currently set bottom position and clear the line
  983. ;  under it
  984. (defun bottom ()
  985.     (set-cursor by bx)
  986.     (clear-eos))
  987.  
  988. ; Clear the screen and go to the bottom
  989. (defun cb ()
  990.     (clear)
  991.     (bottom))
  992.  
  993.  
  994. ; ::::::::::::
  995. ; :: Turtle ::
  996. ; ::::::::::::
  997.  
  998. ; Define "Turtle" class
  999. (setq Turtle (Class :new '(xpos ypos char)))
  1000.  
  1001. ; Answer ":isnew" by initing a position and char and displaying.
  1002. (Turtle :answer :isnew '() '(
  1003.     (setq xpos (setq newx (+ newx 1)))
  1004.     (setq ypos 12)
  1005.     (setq char "*")
  1006.     (self :display)
  1007.     self))
  1008.  
  1009. ; Message ":display" prints its char at its current position
  1010. (Turtle :answer :display '() '(
  1011.     (set-cursor ypos xpos)
  1012.     (princ char)
  1013.     (bottom)
  1014.     self))
  1015.  
  1016. ; Message ":char" sets char to its arg and displays it
  1017. (Turtle :answer :char '(c) '(
  1018.     (setq char c)
  1019.     (self :display)))
  1020.  
  1021. ; Message ":goto" goes to a new place after clearing old one
  1022. (Turtle :answer :goto '(x y) '(
  1023.     (set-cursor ypos xpos) (princ " ")
  1024.     (setq xpos x)
  1025.     (setq ypos y)
  1026.     (self :display)))
  1027.  
  1028. ; Message ":up" moves up if not at top
  1029. (Turtle :answer :up '() '(
  1030.     (if (> ypos 1)
  1031.     (self :goto xpos (- ypos 1))
  1032.     (bottom))))
  1033.  
  1034. ; Message ":down" moves down if not at bottom
  1035. (Turtle :answer :down '() '(
  1036.     (if (< ypos by)
  1037.     (self :goto xpos (+ ypos 1))
  1038.     (bottom))))
  1039.  
  1040. ; Message ":right" moves right if not at right
  1041. (Turtle :answer :right '() '(
  1042.     (if (< xpos 80)
  1043.     (self :goto (+ xpos 1) ypos)
  1044.     (bottom))))
  1045.  
  1046. ; Message ":left" moves left if not at left
  1047. (Turtle :answer :left '() '(
  1048.     (if (> xpos 1)
  1049.     (self :goto (- xpos 1) ypos)
  1050.     (bottom))))
  1051.  
  1052.  
  1053. ; :::::::::::::
  1054. ; :: PTurtle ::
  1055. ; :::::::::::::
  1056.  
  1057. ; Define "DPurtle" programable turtle class
  1058. (setq PTurtle (Class :new '(prog pc) '() Turtle))
  1059.  
  1060. ; Message ":program" stores a program
  1061. (PTurtle :answer :program '(p) '(
  1062.     (setq prog p)
  1063.     (setq pc prog)
  1064.     self))
  1065.  
  1066. ; Message ":step" executes a single program step
  1067. (PTurtle :answer :step '() '(
  1068.     (if (null pc)
  1069.     (setq pc prog))
  1070.     (if pc
  1071.     (progn (self (car pc))
  1072.            (setq pc (cdr pc))))
  1073.     self))
  1074.  
  1075. ; Message ":step#" steps each turtle program n times
  1076. (PTurtle :answer :step# '(n) '(
  1077.     (dotimes (x n) (self :step))
  1078.     self))
  1079.  
  1080.  
  1081. ; ::::::::::::::
  1082. ; :: PTurtles ::
  1083. ; ::::::::::::::
  1084.  
  1085. ; Define "PTurtles" class
  1086. (setq PTurtles (Class :new '(turtles)))
  1087.  
  1088. ; Message ":make" makes a programable turtle and adds it to the collection
  1089. (PTurtles :answer :make '(x y &aux newturtle) '(
  1090.     (setq newturtle (PTurtle :new))
  1091.     (newturtle :goto x y)
  1092.     (setq turtles (cons newturtle turtles))
  1093.     newturtle))
  1094.  
  1095. ; Message ":step" steps each turtle program once
  1096. (PTurtles :answer :step '() '(
  1097.     (mapcar '(lambda (turtle) (turtle :step)) turtles)
  1098.     self))
  1099.  
  1100. ; Message ":step#" steps each turtle program n times
  1101. (PTurtles :answer :step# '(n) '(
  1102.     (dotimes (x n) (self :step))
  1103.     self))
  1104.  
  1105.  
  1106. ; Initialize things and start up
  1107. (setq bx 1)
  1108. (setq by 21)
  1109. (setq newx 1)
  1110.  
  1111. ; Create some programmable turtles
  1112. (cb)
  1113. (setq turtles (PTurtles :new))
  1114. (setq t1 (turtles :make 40 10))
  1115. (setq t2 (turtles :make 41 10))
  1116. (t1 :program '(:left :right :up :down))
  1117. (t2 :program '(:right :left :down :up))
  1118.  
  1119.  
  1120. SHAR_EOF
  1121. fi # end of overwriting check
  1122. if test -f 'pp.lsp'
  1123. then
  1124.     echo shar: will not over-write existing file "'pp.lsp'"
  1125. else
  1126. cat << \SHAR_EOF > 'pp.lsp'
  1127. ;+
  1128. ;               PP 1.0 : (C) Copyright 1985 by Gregory Frascadore
  1129. ;
  1130. ;   This software may be copied, modified, and distributed to others as long
  1131. ;   as it is not sold for profit, and as long as this copyright notice is
  1132. ;   retained intact. For further information contact the author at:
  1133. ;               frascado%umn-cs.CSNET   (on CSNET)
  1134. ;               75106,662               (on CompuServe)
  1135. ;-
  1136.  
  1137. ;+
  1138. ;                               PP 1.0
  1139. ; DESCRIPTION
  1140. ;   PP is a function for producing pretty-printed XLISP code. Version 1.0
  1141. ;   works with XLISP 1.4 and may work with other versions of XLISP or other
  1142. ;   lisp systems.
  1143. ;
  1144. ; UPDATE HISTORY
  1145. ;   Version 1.0 - Original version, 11 April 1985 by Gregory Frascadore.
  1146. ;
  1147. ;-
  1148.  
  1149. ;+
  1150. ; pp
  1151. ;   This function pretty-prints an s-expression.
  1152. ;
  1153. ; format
  1154. ;   (pp <expr> [<sink>] )
  1155. ;
  1156. ;       <expr>  the expression to print.
  1157. ;       <sink>  optional. the sink to print to. defaults to
  1158. ;                   *standard-output*
  1159. ;       <maxlen> the threshold that pp uses to determine when an expr
  1160. ;                   should be broken into several lines. The smaller the
  1161. ;                   value, the more lines are used. Defaults to 45 which
  1162. ;                   seems reasonable and works well too.
  1163. ;-
  1164.  
  1165. (let ((pp-stack* nil)
  1166.       (pp-istack* nil)
  1167.       (pp-currentpos* nil)
  1168.       (pp-sink* nil)
  1169.       (pp-maxlen* nil))
  1170.  
  1171. (defun pp (*expr &optional *sink *maxlen)
  1172.    (setq pp-stack* nil
  1173.          pp-istack* '(0)
  1174.          pp-currentpos* 0
  1175.          pp-sink* *sink
  1176.          pp-maxlen* *maxlen)
  1177.  
  1178.    (if (null pp-sink*) (setq pp-sink* *standard-output*))
  1179.    (if (null pp-maxlen*) (setq pp-maxlen* 45))
  1180.  
  1181.    (pp-expr *expr)
  1182.    (pp-newline)
  1183.    t)
  1184.  
  1185.  
  1186. (defun pp-expr (*expr)
  1187.    (cond ((consp *expr)
  1188.             (pp-list *expr) )
  1189.  
  1190.          (t (pp-prin1 *expr)) ) )
  1191.  
  1192.  
  1193. ;+
  1194. ; pp-list
  1195. ;   Pretty-print a list expression.
  1196. ;       IF <the flatsize length of *expr is less than pp-maxlen*>
  1197. ;           THEN print the expression on one line,
  1198. ;       ELSE
  1199. ;       IF <the car of the expression is an atom>
  1200. ;           THEN print the expression in the following form:
  1201. ;                   "(atom <item1>
  1202. ;                          <item2>
  1203. ;                           ...
  1204. ;                          <itemn> )"
  1205. ;       ELSE
  1206. ;       IF <the car of the expression is a list>
  1207. ;           THEN print the expression in the following form:
  1208. ;                   "(<list1>
  1209. ;                     <item2>
  1210. ;                       ...
  1211. ;                     <itemn> )"
  1212. ;
  1213. ;-
  1214.  
  1215. (defun pp-list (*expr)
  1216.    (cond ((< (flatsize *expr) pp-maxlen*)
  1217.             (pp-prin1 *expr) )
  1218.  
  1219.          ((atom (car *expr))
  1220.             (pp-start)
  1221.             (pp-prin1 (car *expr))
  1222.             (pp-princ " ")
  1223.             (pp-pushmargin)
  1224.             (pp-rest (cdr *expr))
  1225.             (pp-popmargin)
  1226.             (pp-finish) )
  1227.  
  1228.          (t (pp-start)
  1229.             (pp-pushmargin)
  1230.             (pp-rest *expr)
  1231.             (pp-popmargin)
  1232.             (pp-finish) ) ) )
  1233.  
  1234. ;+
  1235. ; pp-rest
  1236. ;   pp-expr each element of a list and do a pp-newline after every call to
  1237. ;   pp-expr except the last.
  1238. ;-
  1239.  
  1240. (defun pp-rest (*rest)
  1241.    (do* ((item* *rest (cdr item*)))
  1242.         ((null item*))
  1243.             (pp-expr (car item*))
  1244.             (if (not (null (cdr item*))) (pp-newline)) ) )
  1245.  
  1246. ;+
  1247. ; pp-newline
  1248. ;   Print out a newline character and indent to the current margin setting
  1249. ;   which is maintained at the top of the pp-istack. Note that is the
  1250. ;   current top of the pp-stack* is a ")" we push a " " so that we will know
  1251. ;   to print a space before closing any parenthesis which were started on a
  1252. ;   different line from the one they are being closed on.
  1253. ;-
  1254.  
  1255. (defun pp-newline ()
  1256.    (if (eql ")" (pp-top pp-stack*)) (pp-push " " pp-stack*))
  1257.  
  1258.    (terpri pp-sink*)
  1259.    (spaces (pp-top pp-istack*) pp-sink*)
  1260.    (setq pp-currentpos* (pp-top pp-istack*)) )
  1261.  
  1262. ;+
  1263. ; pp-finish
  1264. ;   Print out the closing ")". If the top of the pp-stack* has a " " on it,
  1265. ;   then print out the space, then the ")" , and then pop both off the stack.
  1266. ;-
  1267.  
  1268. (defun pp-finish ()
  1269.    (cond ((eql ")" (pp-top pp-stack*))
  1270.             (pp-princ ")") )
  1271.  
  1272.          (t
  1273.             (pp-princ " )")
  1274.             (pp-pop pp-stack*) ) )
  1275.  
  1276.    (pp-pop pp-stack*) )
  1277.  
  1278.  
  1279. ;+
  1280. ; pp-start
  1281. ;   Start printing a list. ie print the "(" and push a ")" on the pp-stack*
  1282. ;   so that pp-finish knows to print a ")" when closing an list.
  1283. ;-
  1284.  
  1285. (defun pp-start ()
  1286.    (pp-princ "(")
  1287.    (pp-push ")" pp-stack*) )
  1288.  
  1289. ;+
  1290. ; pp-princ
  1291. ;   Prints out an expr without any quotes and updates the pp-currentpos*
  1292. ;   pointer so that we know where on the line the cursor is at.
  1293. ;-
  1294.  
  1295. (defun pp-princ (*expr)
  1296.     (setq pp-currentpos* (+ pp-currentpos* (flatc *expr)))
  1297.     (princ *expr pp-sink*) )
  1298.  
  1299. ;+
  1300. ; pp-prin1
  1301. ;   Does the same thing as pp-prin1, except that the expr is printed with
  1302. ;   quotes if needed. Hence pp-prin1 uses flatsize to calc expr length instead
  1303. ;   of flatc.
  1304. ;-
  1305.  
  1306. (defun pp-prin1 (*expr)
  1307.     (setq pp-currentpos* (+ pp-currentpos* (flatsize *expr)))
  1308.     (prin1 *expr pp-sink*) )
  1309.  
  1310. (defmacro pp-push (*item *stack)
  1311.    `(setq ,*stack (cons ,*item ,*stack)) )
  1312.  
  1313.  
  1314. (defmacro pp-pop (*stack)
  1315.    `(let ((top* (car ,*stack)))
  1316.  
  1317.         (setq ,*stack (cdr ,*stack))
  1318.         top*) )
  1319.  
  1320.  
  1321. (defun pp-top (*stack) (car *stack))
  1322.  
  1323.  
  1324. (defun pp-pushmargin ()
  1325.    (pp-push pp-currentpos* pp-istack*) )
  1326.  
  1327.  
  1328. (defun pp-popmargin ()
  1329.    (pp-pop pp-istack*) )
  1330.  
  1331. (defun spaces (n f)
  1332.     (dotimes (x n) (write-char 32 f)))
  1333.  
  1334. )
  1335.  
  1336.  
  1337.  
  1338.  
  1339.  
  1340.  
  1341.  
  1342.  
  1343.  
  1344.  
  1345.  
  1346.  
  1347.  
  1348.  
  1349.  
  1350.  
  1351.  
  1352.  
  1353.  
  1354.  
  1355.  
  1356.  
  1357. SHAR_EOF
  1358. fi # end of overwriting check
  1359. if test -f 'prolog.lsp'
  1360. then
  1361.     echo shar: will not over-write existing file "'prolog.lsp'"
  1362. else
  1363. cat << \SHAR_EOF > 'prolog.lsp'
  1364.  
  1365. ;; The following is a tiny Prolog interpreter in MacLisp
  1366. ;; written by Ken Kahn and modified for XLISP by David Betz.
  1367. ;; It was inspired by other tiny Lisp-based Prologs of
  1368. ;; Par Emanuelson and Martin Nilsson.
  1369. ;; There are no side-effects anywhere in the implementation.
  1370. ;; Though it is VERY slow of course.
  1371.  
  1372. (defun prolog (database &aux goal)
  1373.        (do () ((not (progn (princ "Query?") (setq goal (read)))))
  1374.               (prove (list (rename-variables goal '(0)))
  1375.                      '((bottom-of-environment))
  1376.                      database
  1377.                      1)))
  1378.  
  1379. ;; prove - proves the conjunction of the list-of-goals
  1380. ;;         in the current environment
  1381.  
  1382. (defun prove (list-of-goals environment database level)
  1383.       (cond ((null list-of-goals) ;; succeeded since there are no goals
  1384.              (print-bindings environment environment)
  1385.              (not (y-or-n-p "More?")))
  1386.             (t (try-each database database
  1387.                          (cdr list-of-goals) (car list-of-goals)
  1388.                          environment level))))
  1389.  
  1390. (defun try-each (database-left database goals-left goal environment level 
  1391.                  &aux assertion new-enviroment)
  1392.        (cond ((null database-left) nil) ;; fail since nothing left in database
  1393.              (t (setq assertion
  1394.                       (rename-variables (car database-left)
  1395.                                         (list level)))
  1396.                 (setq new-environment
  1397.                       (unify goal (car assertion) environment))
  1398.                 (cond ((null new-environment) ;; failed to unify
  1399.                        (try-each (cdr database-left) database
  1400.                                  goals-left goal
  1401.                                  environment level))
  1402.                       ((prove (append (cdr assertion) goals-left)
  1403.                               new-environment
  1404.                               database
  1405.                               (+ 1 level)))
  1406.                       (t (try-each (cdr database-left) database
  1407.                                    goals-left goal
  1408.                                    environment level))))))
  1409.  
  1410. (defun unify (x y environment &aux new-environment)
  1411.        (setq x (value x environment))
  1412.        (setq y (value y environment))
  1413.        (cond ((variable-p x) (cons (list x y) environment))
  1414.              ((variable-p y) (cons (list y x) environment))
  1415.              ((or (atom x) (atom y))
  1416.                   (cond ((equal x y) environment)
  1417.                         (t nil)))
  1418.              (t (setq new-environment (unify (car x) (car y) environment))
  1419.                 (cond (new-environment (unify (cdr x) (cdr y) new-environment))
  1420.                   (t nil)))))
  1421.  
  1422. (defun value (x environment &aux binding)
  1423.        (cond ((variable-p x)
  1424.               (setq binding (assoc x environment :test #'equal))
  1425.               (cond ((null binding) x)
  1426.                     (t (value (cadr binding) environment))))
  1427.              (t x)))
  1428.  
  1429. (defun variable-p (x)
  1430.        (and x (listp x) (eq (car x) '?)))
  1431.  
  1432. (defun rename-variables (term list-of-level)
  1433.        (cond ((variable-p term) (append term list-of-level))
  1434.              ((atom term) term)
  1435.              (t (cons (rename-variables (car term) list-of-level)
  1436.                       (rename-variables (cdr term) list-of-level)))))
  1437.  
  1438. (defun print-bindings (environment-left environment)
  1439.        (cond ((cdr environment-left)
  1440.               (cond ((= 0 (nth 2 (caar environment-left)))
  1441.                      (prin1 (cadr (caar environment-left)))
  1442.                      (princ " = ")
  1443.                      (print (value (caar environment-left) environment))))
  1444.               (print-bindings (cdr environment-left) environment))))
  1445.  
  1446. ;; a sample database:
  1447. (setq db '(((father madelyn ernest))
  1448.            ((mother madelyn virginia))
  1449.        ((father david arnold))
  1450.        ((mother david pauline))
  1451.        ((father rachel david))
  1452.        ((mother rachel madelyn))
  1453.            ((grandparent (? grandparent) (? grandchild))
  1454.             (parent (? grandparent) (? parent))
  1455.             (parent (? parent) (? grandchild)))
  1456.            ((parent (? parent) (? child))
  1457.             (mother (? parent) (? child)))
  1458.            ((parent (? parent) (? child))
  1459.             (father (? parent) (? child)))))
  1460.  
  1461. ;; the following are utilities
  1462. (defun y-or-n-p (prompt)
  1463.        (princ prompt)
  1464.        (eq (read) 'y))
  1465.  
  1466. ;; start things going
  1467. (prolog db)
  1468. SHAR_EOF
  1469. fi # end of overwriting check
  1470. if test -f 'pt.lsp'
  1471. then
  1472.     echo shar: will not over-write existing file "'pt.lsp'"
  1473. else
  1474. cat << \SHAR_EOF > 'pt.lsp'
  1475. ; This is a sample XLISP program
  1476. ; It implements a simple form of programmable turtle for VT100 compatible
  1477. ; terminals.
  1478.  
  1479. ; To run it:
  1480.  
  1481. ;    A>xlisp pt
  1482.  
  1483. ; This should cause the screen to be cleared and two turtles to appear.
  1484. ; They should each execute their simple programs and then the prompt
  1485. ; should return.  Look at the code to see how all of this works.
  1486.  
  1487. ; Get some more memory
  1488. (expand 1)
  1489.  
  1490. ; Clear the screen
  1491. (defun clear ()
  1492.     (princ "\e[H\e[J"))
  1493.  
  1494. ; Move the cursor
  1495. (defun setpos (x y)
  1496.     (princ "\e[") (princ y) (princ ";") (princ x) (princ "H"))
  1497.  
  1498. ; Kill the remainder of the line
  1499. (defun kill ()
  1500.     (princ "\e[K"))
  1501.  
  1502. ; Move the cursor to the currently set bottom position and clear the line
  1503. ;  under it
  1504. (defun bottom ()
  1505.     (setpos bx (+ by 1))
  1506.     (kill)
  1507.     (setpos bx by)
  1508.     (kill))
  1509.  
  1510. ; Clear the screen and go to the bottom
  1511. (defun cb ()
  1512.     (clear)
  1513.     (bottom))
  1514.  
  1515.  
  1516. ; ::::::::::::
  1517. ; :: Turtle ::
  1518. ; ::::::::::::
  1519.  
  1520. ; Define "Turtle" class
  1521. (setq Turtle (Class :new '(xpos ypos char)))
  1522.  
  1523. ; Answer ":isnew" by initing a position and char and displaying.
  1524. (Turtle :answer :isnew '() '(
  1525.     (setq xpos (setq newx (+ newx 1)))
  1526.     (setq ypos 12)
  1527.     (setq char "*")
  1528.     (self :display)
  1529.     self))
  1530.  
  1531. ; Message ":display" prints its char at its current position
  1532. (Turtle :answer :display '() '(
  1533.     (setpos xpos ypos)
  1534.     (princ char)
  1535.     (bottom)
  1536.     self))
  1537.  
  1538. ; Message ":char" sets char to its arg and displays it
  1539. (Turtle :answer :char '(c) '(
  1540.     (setq char c)
  1541.     (self :display)))
  1542.  
  1543. ; Message ":goto" goes to a new place after clearing old one
  1544. (Turtle :answer :goto '(x y) '(
  1545.     (setpos xpos ypos) (princ " ")
  1546.     (setq xpos x)
  1547.     (setq ypos y)
  1548.     (self :display)))
  1549.  
  1550. ; Message ":up" moves up if not at top
  1551. (Turtle :answer :up '() '(
  1552.     (if (> ypos 0)
  1553.     (self :goto xpos (- ypos 1))
  1554.     (bottom))))
  1555.  
  1556. ; Message ":down" moves down if not at bottom
  1557. (Turtle :answer :down '() '(
  1558.     (if (< ypos by)
  1559.     (self :goto xpos (+ ypos 1))
  1560.     (bottom))))
  1561.  
  1562. ; Message ":right" moves right if not at right
  1563. (Turtle :answer :right '() '(
  1564.     (if (< xpos 80)
  1565.     (self :goto (+ xpos 1) ypos)
  1566.     (bottom))))
  1567.  
  1568. ; Message ":left" moves left if not at left
  1569. (Turtle :answer :left '() '(
  1570.     (if (> xpos 0)
  1571.     (self :goto (- xpos 1) ypos)
  1572.     (bottom))))
  1573.  
  1574.  
  1575. ; :::::::::::::
  1576. ; :: PTurtle ::
  1577. ; :::::::::::::
  1578.  
  1579. ; Define "DPurtle" programable turtle class
  1580. (setq PTurtle (Class :new '(prog pc) '() Turtle))
  1581.  
  1582. ; Message ":program" stores a program
  1583. (PTurtle :answer :program '(p) '(
  1584.     (setq prog p)
  1585.     (setq pc prog)
  1586.     self))
  1587.  
  1588. ; Message ":step" executes a single program step
  1589. (PTurtle :answer :step '() '(
  1590.     (if (null pc)
  1591.     (setq pc prog))
  1592.     (if pc
  1593.     (progn (self (car pc))
  1594.            (setq pc (cdr pc))))
  1595.     self))
  1596.  
  1597. ; Message ":step#" steps each turtle program n times
  1598. (PTurtle :answer :step# '(n) '(
  1599.     (dotimes (x n) (self :step))
  1600.     self))
  1601.  
  1602.  
  1603. ; ::::::::::::::
  1604. ; :: PTurtles ::
  1605. ; ::::::::::::::
  1606.  
  1607. ; Define "PTurtles" class
  1608. (setq PTurtles (Class :new '(turtles)))
  1609.  
  1610. ; Message ":make" makes a programable turtle and adds it to the collection
  1611. (PTurtles :answer :make '(x y &aux newturtle) '(
  1612.     (setq newturtle (PTurtle :new))
  1613.     (newturtle :goto x y)
  1614.     (setq turtles (cons newturtle turtles))
  1615.     newturtle))
  1616.  
  1617. ; Message ":step" steps each turtle program once
  1618. (PTurtles :answer :step '() '(
  1619.     (mapcar '(lambda (turtle) (turtle :step)) turtles)
  1620.     self))
  1621.  
  1622. ; Message ":step#" steps each turtle program n times
  1623. (PTurtles :answer :step# '(n) '(
  1624.     (dotimes (x n) (self :step))
  1625.     self))
  1626.  
  1627.  
  1628. ; Initialize things and start up
  1629. (setq bx 0)
  1630. (setq by 20)
  1631. (setq newx 0)
  1632.  
  1633. ; Create some programmable turtles
  1634. (cb)
  1635. (setq turtles (PTurtles :new))
  1636. (setq t1 (turtles :make 40 10))
  1637. (setq t2 (turtles :make 41 10))
  1638. (t1 :program '(:left :right :up :down))
  1639. (t2 :program '(:right :left :down :up))
  1640.  
  1641.  
  1642. SHAR_EOF
  1643. fi # end of overwriting check
  1644. if test -f 'queens.lsp'
  1645. then
  1646.     echo shar: will not over-write existing file "'queens.lsp'"
  1647. else
  1648. cat << \SHAR_EOF > 'queens.lsp'
  1649. ;
  1650. ; Place n queens on a board
  1651. ;  See Winston and Horn Ch. 11
  1652. ; 
  1653. ; Usage:
  1654. ;    (queens <n>)
  1655. ;          where <n> is an integer -- the size of the board - try (queens 4)
  1656.  
  1657. (defun cadar (x)
  1658.   (car (cdr (car x))))
  1659.  
  1660. ; Do two queens threaten each other ?
  1661. (defun threat (i j a b)
  1662.   (or (equal i a)            ;Same row
  1663.       (equal j b)            ;Same column
  1664.       (equal (- i j) (- a b))        ;One diag.
  1665.       (equal (+ i j) (+ a b))))        ;the other diagonal
  1666.  
  1667. ; Is poistion (n,m) on the board safe for a queen ?
  1668. (defun conflict (n m board)
  1669.   (cond ((null board) nil)
  1670.     ((threat n m (caar board) (cadar board)) t)
  1671.     (t (conflict n m (cdr board)))))
  1672.  
  1673.  
  1674. ; Place queens on a board of size SIZE
  1675. (defun queens (size)
  1676.   (prog (n m board)
  1677.     (setq board nil)
  1678.     (setq n 1)            ;Try the first row
  1679.     loop-n
  1680.     (setq m 1)            ;Column 1
  1681.     loop-m
  1682.     (cond ((conflict n m board) (go un-do-m))) ;Check for conflict
  1683.     (setq board (cons (list n m) board))       ; Add queen to board
  1684.     (cond ((> (setq n (1+ n)) size)            ; Placed N queens ?
  1685.            (print (reverse board))))           ; Print config
  1686.     (go loop-n)                       ; Next row which column?
  1687.     un-do-n
  1688.     (cond ((null board) (return 'Done))        ; Tried all possibilities
  1689.           (t (setq m (cadar board))           ; No, Undo last queen placed
  1690.          (setq n (caar board))
  1691.          (setq board (cdr board))))
  1692.  
  1693.     un-do-m
  1694.     (cond ((> (setq m (1+ m)) size)          ; Go try next column
  1695.            (go un-do-n))
  1696.           (t (go loop-m)))))
  1697. SHAR_EOF
  1698. fi # end of overwriting check
  1699. if test -f 'queens2.lsp'
  1700. then
  1701.     echo shar: will not over-write existing file "'queens2.lsp'"
  1702. else
  1703. cat << \SHAR_EOF > 'queens2.lsp'
  1704. ;
  1705. ; Place n queens on a board (graphical version)
  1706. ;  See Winston and Horn Ch. 11
  1707. ; 
  1708. ; Usage:
  1709. ;    (queens <n>)
  1710. ;          where <n> is an integer -- the size of the board - try (queens 4)
  1711.  
  1712. (defun cadar (x)
  1713.   (car (cdr (car x))))
  1714.  
  1715. ; Do two queens threaten each other ?
  1716. (defun threat (i j a b)
  1717.   (or (equal i a)            ;Same row
  1718.       (equal j b)            ;Same column
  1719.       (equal (- i j) (- a b))        ;One diag.
  1720.       (equal (+ i j) (+ a b))))        ;the other diagonal
  1721.  
  1722. ; Is poistion (n,m) on the board safe for a queen ?
  1723. (defun conflict (n m board)
  1724.   (cond ((null board) nil)
  1725.     ((threat n m (caar board) (cadar board)) t)
  1726.     (t (conflict n m (cdr board)))))
  1727.  
  1728.  
  1729. ; Place queens on a board of size SIZE
  1730. (defun queens (size)
  1731.   (prog (n m board soln)
  1732.     (setq soln 0)            ;Solution #
  1733.     (setq board nil)
  1734.     (setq n 1)            ;Try the first row
  1735.     loop-n
  1736.     (setq m 1)            ;Column 1
  1737.     loop-m
  1738.     (cond ((conflict n m board) (go un-do-m))) ;Check for conflict
  1739.     (setq board (cons (list n m) board))       ; Add queen to board
  1740.     (cond ((> (setq n (1+ n)) size)            ; Placed N queens ?
  1741.            (print-board (reverse board) (setq soln (1+ soln))))) ; Print it
  1742.     (go loop-n)                       ; Next row which column?
  1743.     un-do-n
  1744.     (cond ((null board) (return 'Done))        ; Tried all possibilities
  1745.           (t (setq m (cadar board))           ; No, Undo last queen placed
  1746.          (setq n (caar board))
  1747.          (setq board (cdr board))))
  1748.  
  1749.     un-do-m
  1750.     (cond ((> (setq m (1+ m)) size)          ; Go try next column
  1751.            (go un-do-n))
  1752.           (t (go loop-m)))))
  1753.  
  1754.  
  1755. ;Print a board
  1756. (defun print-board  (board soln &aux size)
  1757.   (setq size (length board))        ;we can find our own size
  1758.   (terpri)
  1759.   (princ "\t\tSolution: ")
  1760.   (print soln)
  1761.   (terpri)
  1762.   (princ "\t")
  1763.   (print-header size 1)
  1764.   (terpri)
  1765.   (print-board-aux board size 1)
  1766.   (terpri))
  1767.  
  1768. ; Put Column #'s on top
  1769. (defun print-header (size n)
  1770.   (cond ((> n size) terpri)
  1771.     (t (princ n)
  1772.        (princ " ")
  1773.        (print-header size (1+ n)))))
  1774.  
  1775. (defun print-board-aux (board size row)
  1776.   (terpri)
  1777.   (cond ((null board))
  1778.     (t (princ row)            ;print the row #
  1779.        (princ "\t")
  1780.        (print-board-row (cadar board) size 1) ;Print the row
  1781.        (print-board-aux (cdr board) size (1+ row)))))  ;Next row
  1782.  
  1783. (defun print-board-row (column size n)
  1784.   (cond ((> n size))
  1785.     (t (cond ((equal column n) (princ "Q"))
  1786.          (t (princ ".")))
  1787.        (princ " ")
  1788.        (print-board-row column size (1+ n)))))
  1789. SHAR_EOF
  1790. fi # end of overwriting check
  1791. if test -f 'simplepp.lsp'
  1792. then
  1793.     echo shar: will not over-write existing file "'simplepp.lsp'"
  1794. else
  1795. cat << \SHAR_EOF > 'simplepp.lsp'
  1796. ;
  1797. ; a pretty-printer, with hooks for the editor
  1798. ;
  1799.  
  1800. ; First, the terminal width and things to manipulate it
  1801. (setq pp$terminal-width 79)
  1802.  
  1803. (defmacro get-terminal-width nil
  1804.   pp$terminal_width)
  1805.  
  1806. (defmacro set-terminal-width (new-width)
  1807.   (let ((old-width pp$terminal-width))
  1808.     (setq pp$terminal-width new-width)
  1809.     old-width))
  1810. ;
  1811. ; Now, a basic, simple pretty-printer
  1812. ; pp$pp prints expression, indented to indent-level, assuming that things
  1813. ; have already been indented to indent-so-far. It *NEVER* leaves the cursor
  1814. ; on a new line after printing expression. This is to make the recursion
  1815. ; simpler. This may change in the future, in which case pp$pp could vanish.
  1816. ;
  1817. (defun pp$pp (expression indent-level indent-so-far)
  1818. ; Step one, make sure we've indented to indent-level
  1819.   (dotimes (x (- indent-level indent-so-far)) (princ " "))
  1820. ; Step two, if it's an atom or it fits just print it
  1821.   (cond ((or (not (consp expression))
  1822.          (> (- pp$terminal-width indent-level) (flatsize expression)))
  1823.      (prin1 expression))
  1824. ; else, print open paren, the car, then each sub expression, then close paren
  1825.     (t (princ "(")
  1826.        (pp$pp (car expression) (1+ indent-level) (1+ indent-level))
  1827.        (if (cadr expression)
  1828.            (progn
  1829.          (if (or (consp (car expression))
  1830.              (> (/ (flatsize (car expression)) 3)
  1831.                 pp$terminal-width))
  1832.              (progn (terpri)
  1833.                 (pp$pp (cadr expression) 
  1834.                    (1+ indent-level)
  1835.                    0))
  1836.              (pp$pp (cadr expression)
  1837.                 (+ 2 indent-level (flatsize (car expression)))
  1838.                 (+ 1 indent-level (flatsize (car expression)))))
  1839.          (dolist (current-expression (cddr expression))
  1840.              (terpri)
  1841.              (pp$pp current-expression
  1842.                 (+ 2 indent-level 
  1843.                    (flatsize (car expression)))
  1844.                 0))))
  1845.        (princ ")")))
  1846.   nil)
  1847. ;
  1848. ; Now, the thing that outside users should call
  1849. ; We have to have an interface layer to get the final terpri after pp$pp.
  1850. ; This also allows hiding the second and third args to pp$pp. Said args
  1851. ; being required makes the pp recursion loop run faster (don't have to map
  1852. ; nil's to 0).
  1853. ;    The where arg to pp is ingnored, as the obvious hack to pp$pp [adding
  1854. ; an extra arg to every call to a print routine or pp$pp] doesn't work,
  1855. ; printing nothing when where is nil.
  1856. ;
  1857. (defun pp (expression &optional where)
  1858. "Print EXPRESSION on STREAM, prettily"
  1859.   (pp$pp expression 0 0)
  1860.   (terpri))
  1861. SHAR_EOF
  1862. fi # end of overwriting check
  1863. if test -f 'trace.lsp'
  1864. then
  1865.     echo shar: will not over-write existing file "'trace.lsp'"
  1866. else
  1867. cat << \SHAR_EOF > 'trace.lsp'
  1868. (setq *tracelist* nil)
  1869.  
  1870. (defun evalhookfcn (expr &aux val)
  1871.        (if (and (consp expr) (member (car expr) *tracelist*))
  1872.            (progn (princ ">>> ") (print expr)
  1873.                   (setq val (evalhook expr evalhookfcn nil))
  1874.                   (princ "<<< ") (print val))
  1875.            (evalhook expr evalhookfcn nil)))
  1876.  
  1877. (defun trace (fun)
  1878.        (if (not (member fun *tracelist*))
  1879.        (progn (setq *tracelist* (cons fun *tracelist*))
  1880.                   (setq *evalhook* evalhookfcn)))
  1881.        *tracelist*)
  1882.  
  1883. (defun untrace (fun)
  1884.        (if (null (setq *tracelist* (delete fun *tracelist*)))
  1885.            (setq *evalhook* nil))
  1886.        *tracelist*)
  1887. SHAR_EOF
  1888. fi # end of overwriting check
  1889. #    End of shell archive
  1890. exit 0
  1891.